home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Plurals / Modules / mexp.em < prev    next >
Lisp/Scheme  |  1992-04-28  |  1KB  |  57 lines
  1. (defmodule mexp
  2.   (standard0
  3.    list-fns
  4.    
  5.    module-operators
  6.    )
  7.   ()
  8.     ;; you expected comments?
  9.   (defmacro expand-forms ()
  10.     `(do-expand (car (reify-env))))
  11.  
  12.   (defun do-expand (name)
  13.     (let ((infile (open (format nil "~a.em" name)))
  14.       (outfile (open (format nil "/tmp/~a.em" name) 'output)))
  15.       (let ((forms (read infile)))
  16.     (let ((res (expand-forms-1 forms name)))
  17.       (write res outfile)
  18.       (format outfile "~%~%")
  19.       (close outfile)
  20.       (close infile))))
  21.     nil)
  22.  
  23.   (defun expand-forms-1 (x m)
  24.     (cond ((null x) nil)
  25.       ((atom x) x)
  26.       (t (let ((xx (macro-namep (car x) m)))
  27.            (if xx
  28.            (expand-forms-1 (apply xx (cdr x))
  29.                    m)
  30.          (cons (expand-forms-1 (car x) m)
  31.                (my-mapcar (lambda (form) 
  32.                     (expand-forms-1 form m))
  33.                   (cdr x))))))))
  34.                    
  35.   
  36.      
  37.   (defun macro-namep (sym mod)
  38.     (if (symbolp sym)
  39.     (if (dynamic-accessible-p (get-module mod) sym)
  40.         (let ((xx (dynamic-access (get-module mod) sym)))
  41.           (if (macrop xx) 
  42.           xx
  43.         nil))
  44.       nil)
  45.       nil))
  46.   
  47.   (defun my-mapcar (fn l)
  48.     (cond ((null l) nil)
  49.       ((atom l) l)
  50.       (t (cons (fn (car l)) 
  51.            (my-mapcar fn (cdr l))))))
  52.  
  53.   (export expand-forms expand-forms-1 reify-env do-expand)
  54.   ;; end module
  55.   )
  56.  
  57.